; File: WINDOWS.LSP  (C)	    03/06/91		Soft Warehouse, Inc.


;		  * * *  muLISP Window Manager	* * *

(SETQ *PRODUCT* "muLISP")
(SETQ *CURRENT-WINDOW* 0)
(SETQ *WINDOWS* NIL)
(SETQ *SCREEN-ROWS* NIL)		; Number of rows on screen
(SETQ *SCREEN-COLS* NIL)		; Number of columns on screen
(SETQ *SCREEN-CLIP* 0)			; Screen bottom clip lines
(SETQ *CURSOR-ON* NIL)			; Turn cursor on flag

(DEFUN WINDOWS (*COMMAND-LINE*
    WINDOW PANE EXPN ROW1 COL1 ROW2 COL2
    *AUTO-NEWLINE* *INTERRUPT-HOOK* *GC-HOOK*)
  (SAVE-STATE)				; Save external state
  (INITIAL-ENTRY)			; Initial entry routine
  (CURSOR-OFF)				; Turn OFF cursor
  (CSMEMORY 940 0 T)			; Disable Ctrl-V insert mode toggle
  (CSMEMORY 962 6 T)			; Disable Ins insert mode toggle
  (MAKE-WINDOW NIL)			; Take whole window
  (SETQ *SCREEN-ROWS* (- (THIRD (MAKE-WINDOW)) *SCREEN-CLIP*)
	*SCREEN-COLS* (FOURTH (MAKE-WINDOW)))
  (SETQ *GCHOOK* 'GCHOOK)		; Post-GC statistics gather handler
  (GCHOOK)				; Initialize free stats for next GC
  (IF (NOT *WINDOWS*)
      (SETQ *WINDOWS* (LIST (LIST 0 (LIST NIL) 0 0
			      (- *SCREEN-ROWS* 5) *SCREEN-COLS*
			      (LIST *WORK-COLOR*) (LIST *WORK-BACKGROUND*)))) )
  (CLEAR-SCREEN)
  (BORDER-WINDOWS)
  (OPTION-WINDOW 0)
  (STATUS-WINDOW)
  (CLEAR-SCREEN)
  (WINDOW-STATE *CURRENT-WINDOW* (APPLY *INIT-WINDOW* 'CREATE-WINDOW NIL))
  (SETQ *COMMAND-LINE* "")
  (UPDATE-WINDOWS)
  (LOOP
    (SETQ EXPN (CATCH NIL
	    (APPLY (CAR (WINDOW-STATE)) 'RUN-WINDOW (CDR (WINDOW-STATE))) ))

    ( ((EQ *THROW-TAG* 'CLOSE-WINDOW)			; Close window
	((NOT ((LAMBDA (*CURRENT-WINDOW*)
		(APPLY (CAR (WINDOW-STATE)) 'CLOSE-WINDOW (CDR (WINDOW-STATE))))
		  EXPN)))
	((CDR (WINDOW-STATES EXPN))			; Multi-layers?
	  (WINDOW-STATES EXPN
			 (DELETE-NTH (WINDOW-STATES EXPN) (WINDOW-PANE EXPN)))
	  (REPLACE-NTH (DELETE-NTH (NTH 6 (NTH EXPN *WINDOWS*))
				   (WINDOW-PANE EXPN))
		       (NTH EXPN *WINDOWS*)
		       6)
	  (REPLACE-NTH (DELETE-NTH (NTH 7 (NTH EXPN *WINDOWS*))
				   (WINDOW-PANE EXPN))
		       (NTH EXPN *WINDOWS*)
		       7)
	  (WINDOW-PANE EXPN (MIN (WINDOW-PANE EXPN)
				 (SUB1 (LENGTH (WINDOW-STATES EXPN)))))
	  (UPDATE-WINDOW EXPN) )
	(SETQ ROW1 (SUB1 (WINDOW-ROW EXPN))
	      COL1 (SUB1 (WINDOW-COL EXPN))
	      ROW2 (+ (WINDOW-ROW EXPN) (WINDOW-ROWS EXPN))
	      COL2 (+ (WINDOW-COL EXPN) (WINDOW-COLS EXPN))
	      *WINDOWS* (DELETE-NTH *WINDOWS* EXPN))
	( ((< *CURRENT-WINDOW* EXPN))
	  ((ZEROP *CURRENT-WINDOW*))
	  (SETQ *CURRENT-WINDOW* (SUB1 *CURRENT-WINDOW*)) )
	((= (LENGTH *WINDOWS*) 1)
	  (WINDOW-ROW 0 0)
	  (WINDOW-COL 0 0)
	  (WINDOW-ROWS 0 (- *SCREEN-ROWS* 5))
	  (WINDOW-COLS 0 *SCREEN-COLS*)
	  (UPDATE-WINDOW 0)
	  (BORDER-WINDOWS) )
	( ((AND (UPPER-RIGHT ROW1 COL1) (LOWER-RIGHT ROW2 COL1))
	    (LOOP
	      ((= ROW1 ROW2))
	      (SETQ EXPN (UPPER-RIGHT ROW1 COL1))
	      (WINDOW-COLS EXPN (- (+ (WINDOW-COLS EXPN) COL2) COL1))
	      (UPDATE-WINDOW EXPN)
	      (SETQ ROW1 (+ ROW1 (WINDOW-ROWS EXPN) 1)) ) )
	  ((AND (LOWER-LEFT ROW1 COL1) (LOWER-RIGHT ROW1 COL2))
	    (LOOP
	      ((= COL1 COL2))
	      (SETQ EXPN (LOWER-LEFT ROW1 COL1))
	      (WINDOW-ROWS EXPN (- (+ (WINDOW-ROWS EXPN) ROW2) ROW1))
	      (UPDATE-WINDOW EXPN)
	      (SETQ COL1 (+ COL1 (WINDOW-COLS EXPN) 1)) ) )
	  ((AND (UPPER-LEFT ROW1 COL2) (LOWER-LEFT ROW2 COL2))
	    (LOOP
	      ((= ROW1 ROW2))
	      (SETQ EXPN (UPPER-LEFT ROW1 COL2))
	      (WINDOW-COL EXPN (ADD1 COL1))
	      (WINDOW-COLS EXPN (- (+ (WINDOW-COLS EXPN) COL2) COL1))
	      (UPDATE-WINDOW EXPN)
	      (SETQ ROW1 (+ ROW1 (WINDOW-ROWS EXPN) 1)) ) )
	  ((AND (UPPER-LEFT ROW2 COL1) (UPPER-RIGHT ROW2 COL2))
	    (LOOP
	      ((= COL1 COL2))
	      (SETQ EXPN (UPPER-LEFT ROW2 COL1))
	      (WINDOW-ROW EXPN (ADD1 ROW1))
	      (WINDOW-ROWS EXPN (- (+ (WINDOW-ROWS EXPN) ROW2) ROW1))
	      (UPDATE-WINDOW EXPN)
	      (SETQ COL1 (+ COL1 (WINDOW-COLS EXPN) 1)) ) ) )
	(BORDER-WINDOWS) )

      ((EQ *THROW-TAG* 'SWITCH-PANE)			; Switch panes
	(WINDOW-PANE *CURRENT-WINDOW* EXPN)
	(UPDATE-WINDOW *CURRENT-WINDOW*) )

      ((EQ *THROW-TAG* 'SWITCH-WINDOW)			; Switch windows
	((= EXPN *CURRENT-WINDOW*))
	(MAKE-WINDOW NIL)
	(SET-CURSOR (SUB1 (WINDOW-ROW *CURRENT-WINDOW*))
		    (SUB1 (WINDOW-COL *CURRENT-WINDOW*)))
	(FRAME-COLOR *FRAME-COLOR* *MENU-BACKGROUND*)
	(PRIN1 (ADD1 *CURRENT-WINDOW*))
	(SETQ *CURRENT-WINDOW* EXPN
	      *CURRENT-AREA*)
	(SET-CURSOR (SUB1 (WINDOW-ROW *CURRENT-WINDOW*))
		    (SUB1 (WINDOW-COL *CURRENT-WINDOW*)))
	(FRAME-COLOR *MENU-BACKGROUND* *FRAME-COLOR* 0)
	(PRIN1 (ADD1 *CURRENT-WINDOW*)) )

      ((EQ *THROW-TAG* 'SPLIT-WINDOW)			; Split window
	(WINDOW-PANE (ADD1 *CURRENT-WINDOW*) 0)
	(WINDOW-STATES (ADD1 *CURRENT-WINDOW*)
		       (LIST (COPY-TREE (WINDOW-STATE))))
;If the above 3 lines of code are replaced with the next 2 lines, the new
;window will contain a copy of the hidden panes as well as the top pane.
;	(WINDOW-STATES (ADD1 *CURRENT-WINDOW*)
;		       (COPY-TREE (WINDOW-STATES)))
	(BORDER-WINDOWS)
	(UPDATE-WINDOW *CURRENT-WINDOW*)
	(UPDATE-WINDOW (ADD1 *CURRENT-WINDOW*)) )

      ((EQ *THROW-TAG* 'DESIGNATE-WINDOW)		; Designate window
	((APPLY (CAR (WINDOW-STATE)) 'CLOSE-WINDOW (CDR (WINDOW-STATE)))
	  (WINDOW-STATE *CURRENT-WINDOW* (APPLY EXPN 'CREATE-WINDOW NIL))
	  (UPDATE-WINDOW *CURRENT-WINDOW*) ) )

      ((EQ *THROW-TAG* 'OPEN-PANE)			; Open pane
	(WINDOW-STATES *CURRENT-WINDOW*
		(INSERT-NTH (APPLY EXPN 'CREATE-WINDOW NIL)
			    (WINDOW-STATES) (WINDOW-PANE)))
	(RPLACD (WORK-COLOR) (CONS (CAR (WORK-COLOR)) (CDR (WORK-COLOR))))
	(RPLACD (WORK-BACKGROUND) (CONS (CAR (WORK-BACKGROUND))
					(CDR (WORK-BACKGROUND))))
	(UPDATE-WINDOW *CURRENT-WINDOW*) )

      ((EQ *THROW-TAG* 'QUIT-PROGRAM)			; Quit program
	(SETQ WINDOW 0)
	(LOOP
	  ((= WINDOW (LENGTH *WINDOWS*))
	    ( ((RESTORE-STATE)) 		; Restore external video state
	      (MAKE-WINDOW (SUB1 *SCREEN-ROWS*) 0 1 *SCREEN-COLS*)
	      (CLEAR-SCREEN) )
	    (SYSTEM) )
	  (SETQ PANE 0)
	  ((LOOP
	    ((= PANE (LENGTH (WINDOW-STATES WINDOW))) NIL)
	    ((NOT (APPLY (CAR (NTH PANE (WINDOW-STATES WINDOW))) 'CLOSE-WINDOW
		     (CDR (NTH PANE (WINDOW-STATES WINDOW))))))
	    (INCQ PANE) ))
	  (INCQ WINDOW) ) )

      ((EQ *THROW-TAG* 'SWITCH-SCREEN)			; Switch screen
	(CURSOR-OFF)
	(MAKE-WINDOW NIL)
	( ((ZEROP (WINDOW-ROW 0))
	    (WINDOW-ROWS 0 (- (THIRD (MAKE-WINDOW)) 5 *SCREEN-CLIP*))
	    (WINDOW-COLS 0 (FOURTH (MAKE-WINDOW))) )
	  (SETQ ROW1 (/ (- *SCREEN-ROWS* 5) (- (THIRD (MAKE-WINDOW)) 5 *SCREEN-CLIP*))
		WINDOW (LENGTH *WINDOWS*))
	  (LOOP
	    ((ZEROP WINDOW))
	    (DECQ WINDOW)
	    (SETQ ROW2 (ROUND (+ (WINDOW-ROW WINDOW) (WINDOW-ROWS WINDOW)) ROW1))
	    (WINDOW-ROW WINDOW (ADD1 (ROUND (SUB1 (WINDOW-ROW WINDOW)) ROW1)))
	    (WINDOW-ROWS WINDOW (- ROW2 (WINDOW-ROW WINDOW))) )
	  (SETQ COL1 (/ (SUB1 *SCREEN-COLS*) (- (FOURTH (MAKE-WINDOW)) 1))
		WINDOW (LENGTH *WINDOWS*))
	  (LOOP
	    ((ZEROP WINDOW))
	    (DECQ WINDOW)
	    (SETQ COL2 (ROUND (+ (WINDOW-COL WINDOW) (WINDOW-COLS WINDOW)) COL1))
	    (WINDOW-COL WINDOW (ADD1 (ROUND (SUB1 (WINDOW-COL WINDOW)) COL1)))
	    (WINDOW-COLS WINDOW (- COL2 (WINDOW-COL WINDOW))) ) )
	(SETQ *SCREEN-ROWS* (- (THIRD (MAKE-WINDOW)) *SCREEN-CLIP*)
	      *SCREEN-COLS* (FOURTH (MAKE-WINDOW)))
	(BORDER-WINDOWS)
	(UPDATE-WINDOWS)
	(SETQ *PROMPT* ""
	      *OPTION-TREE*) )

      ((EQ *THROW-TAG* 'DRIVER))			; Throw to driver
      ((EQ *THROW-TAG* "Memory Full")			; Memory full error
	(ERROR-MESSAGE "Memory Full") )

      (THROW *THROW-TAG* EXPN) ) ) )			; Unrecognized throw

(DEFUN UPDATE-WINDOWS (
    WINDOW)
  (SETQ WINDOW 0)
  (LOOP
    ((= WINDOW (LENGTH *WINDOWS*)))
    (UPDATE-WINDOW WINDOW)
    (INCQ WINDOW) ) )

(DEFUN UPDATE-WINDOW (*CURRENT-WINDOW*)
  (APPLY (CAR (WINDOW-STATE)) 'UPDATE-WINDOW (CDR (WINDOW-STATE))) )

(DEFUN QUIT-PROGRAM ()
  (THROW 'QUIT-PROGRAM) )

;		* * *	Window Option Functions   * * *

(DEFUN CHANGE-WINDOW ()
  (EXECUTE-OPTION *OPTION-PROMPT* '(
	("Close" . CLOSE-WINDOW)
	("Designate" . DESIGNATE-WINDOW)
	("Flip" . NEXT-PANE)
	("Goto" . GOTO-WINDOW)
	("Next" . NEXT-WINDOW)
	("Open" . OPEN-PANE)
	("Previous" . LAST-WINDOW)
	("Split" . (
		("Horizontal" . HORIZONTAL-SPLIT)
		("Vertical" . VERTICAL-SPLIT) )) )) )


(DEFUN CLOSE-WINDOW (
    WINDOW)
  ((OR (CDR *WINDOWS*) (CDR (WINDOW-STATES)))
    (RPLACA (CAR CLOSE-WINDOW) (ADD1 *CURRENT-WINDOW*))
    (LOOP
      ((NOT (MODE-QUERY CLOSE-WINDOW)) NIL)
      (SETQ WINDOW (PARSE-INTEGER-CAR (CAR CLOSE-WINDOW)))
      ((AND WINDOW (<= 1 WINDOW (LENGTH *WINDOWS*)))
	(THROW 'CLOSE-WINDOW (SUB1 WINDOW)) )
      (ERROR-BEEP) ) ) )

(SETQ CLOSE-WINDOW '(("" "Enter window number" "Window" 4)))


(DEFUN OPEN-PANE ()
  (RPLACA (CAR DESIGNATE-WINDOW) (CAR (WINDOW-STATE)))
  (REPLACE-NTH *WINDOW-TYPES* (CAR DESIGNATE-WINDOW) 3)
  ((MODE-QUERY DESIGNATE-WINDOW)
    (THROW 'OPEN-PANE (CAAR DESIGNATE-WINDOW)) ) )

(DEFUN DESIGNATE-WINDOW ()
  (RPLACA (CAR DESIGNATE-WINDOW) (CAR (WINDOW-STATE)))
  (REPLACE-NTH *WINDOW-TYPES* (CAR DESIGNATE-WINDOW) 3)
  ((MODE-QUERY DESIGNATE-WINDOW)
    (THROW 'DESIGNATE-WINDOW (CAAR DESIGNATE-WINDOW)) ) )

(SETQ DESIGNATE-WINDOW '(("" "Enter window type" "Type" NIL)))

(IF (ATOM *WINDOW-TYPES*)
    (SETQ *WINDOW-TYPES*)
    (RPLACD (LAST *WINDOW-TYPES*)) )


(DEFUN GOTO-WINDOW (
    WINDOW)
  (RPLACA (CAR GOTO-WINDOW)
	  (ADD1 (MOD (ADD1 *CURRENT-WINDOW*) (LENGTH *WINDOWS*))))
  (LOOP
    ((NOT (MODE-QUERY GOTO-WINDOW)) NIL)
    (SETQ WINDOW (PARSE-INTEGER-CAR (CAR GOTO-WINDOW)))
    ((AND WINDOW (<= 1 WINDOW (LENGTH *WINDOWS*)))
      (THROW 'SWITCH-WINDOW (SUB1 WINDOW)) )
    (ERROR-BEEP) ) )

(SETQ GOTO-WINDOW '(("" "Enter window number" "Window" 4)))


(DEFUN LAST-WINDOW ()
  (THROW 'SWITCH-WINDOW (MOD (SUB1 *CURRENT-WINDOW*) (LENGTH *WINDOWS*))) )

(DEFUN NEXT-WINDOW ()
  (THROW 'SWITCH-WINDOW (MOD (ADD1 *CURRENT-WINDOW*) (LENGTH *WINDOWS*))) )

(DEFUN LAST-PANE ()
  (THROW 'SWITCH-PANE (MOD (SUB1 (WINDOW-PANE)) (LENGTH (WINDOW-STATES)))) )

(DEFUN NEXT-PANE ()
  (THROW 'SWITCH-PANE (MOD (ADD1 (WINDOW-PANE)) (LENGTH (WINDOW-STATES)))) )


(DEFUN HORIZONTAL-SPLIT (
    ROW)
  (RPLACA (CAR HORIZONTAL-SPLIT) (CEILING (WINDOW-ROWS) 2))
  (LOOP
    ((NOT (MODE-QUERY HORIZONTAL-SPLIT)) NIL)
    (SETQ ROW (PARSE-INTEGER-CAR (CAR HORIZONTAL-SPLIT)))
    ((AND ROW (<= 2 ROW (- (WINDOW-ROWS) 2)))
      (WINDOW-SPLIT-AUX)
      (WINDOW-ROWS *CURRENT-WINDOW* (SUB1 ROW))
      (WINDOW-ROW (ADD1 *CURRENT-WINDOW*)
		  (+ (WINDOW-ROW (ADD1 *CURRENT-WINDOW*)) ROW))
      (WINDOW-ROWS (ADD1 *CURRENT-WINDOW*)
		   (- (WINDOW-ROWS (ADD1 *CURRENT-WINDOW*)) ROW))
      (THROW 'SPLIT-WINDOW) )
    (ERROR-BEEP) ) )

(SETQ HORIZONTAL-SPLIT '(("" "Enter line number" "At line" 4)))


(DEFUN VERTICAL-SPLIT (
    COL)
  (RPLACA (CAR VERTICAL-SPLIT) (CEILING (WINDOW-COLS) 2))
  (LOOP
    ((NOT (MODE-QUERY VERTICAL-SPLIT)) NIL)
    (SETQ COL (PARSE-INTEGER-CAR (CAR VERTICAL-SPLIT)))
    ((AND COL (<= 7 COL (- (WINDOW-COLS) 6)))
      ( ((EVENP COL))
	((SMALL-SCREENP))
	(DECQ COL) )
      (WINDOW-SPLIT-AUX)
      (WINDOW-COLS *CURRENT-WINDOW* (SUB1 COL))
      (WINDOW-COL (ADD1 *CURRENT-WINDOW*)
		  (+ (WINDOW-COL (ADD1 *CURRENT-WINDOW*)) COL))
      (WINDOW-COLS (ADD1 *CURRENT-WINDOW*)
		   (- (WINDOW-COLS (ADD1 *CURRENT-WINDOW*)) COL))
      (THROW 'SPLIT-WINDOW) )
    (ERROR-BEEP) ) )

(SETQ VERTICAL-SPLIT '(("" "Enter column number" "At column" 4)))


(DEFUN WINDOW-SPLIT-AUX (
    LST1 LST2)
  (CURRENT-WINDOW T)
  ( ((ZEROP (WINDOW-ROW 0))
      (WINDOW-ROW 0 1)
      (WINDOW-COL 0 1)
      (WINDOW-ROWS 0 (SUB1 (WINDOW-ROWS 0)))
      (WINDOW-COLS 0 (- (WINDOW-COLS 0) 2)) ) )
  (SETQ LST1 (NTHCDR *CURRENT-WINDOW* *WINDOWS*)
	LST2 (CAR LST1)
	LST2 (NCONC (BUTLAST LST2 2) (LIST (COPY-LIST (SEVENTH LST2))
					   (COPY-LIST (EIGHTH LST2)))))
  (RPLACD LST1 (CONS LST2 (CDR LST1))) )

;		* * *	Window Predicates   * * *

(DEFUN UPPER-LEFT (ROW COL
    WINDOW)
  (SETQ WINDOW 0)
  (LOOP
    ((= WINDOW (LENGTH *WINDOWS*)) NIL)
    ((AND (= ROW (SUB1 (WINDOW-ROW WINDOW)))
	  (= COL (SUB1 (WINDOW-COL WINDOW)))) WINDOW)
    (INCQ WINDOW) ) )

(DEFUN UPPER-RIGHT (ROW COL
    WINDOW)
  (SETQ WINDOW 0)
  (LOOP
    ((= WINDOW (LENGTH *WINDOWS*)) NIL)
    ((AND (= ROW (SUB1 (WINDOW-ROW WINDOW)))
	  (= COL (+ (WINDOW-COL WINDOW) (WINDOW-COLS WINDOW)))) WINDOW)
    (INCQ WINDOW) ) )

(DEFUN LOWER-LEFT (ROW COL
    WINDOW)
  (SETQ WINDOW 0)
  (LOOP
    ((= WINDOW (LENGTH *WINDOWS*)) NIL)
    ((AND (= ROW (+ (WINDOW-ROW WINDOW) (WINDOW-ROWS WINDOW)))
	  (= COL (SUB1 (WINDOW-COL WINDOW)))) WINDOW)
    (INCQ WINDOW) ) )

(DEFUN LOWER-RIGHT (ROW COL
    WINDOW)
  (SETQ WINDOW 0)
  (LOOP
    ((= WINDOW (LENGTH *WINDOWS*)) NIL)
    ((AND (= ROW (+ (WINDOW-ROW WINDOW) (WINDOW-ROWS WINDOW)))
	  (= COL (+ (WINDOW-COL WINDOW) (WINDOW-COLS WINDOW)))) WINDOW)
    (INCQ WINDOW) ) )

;		* * *	Window State Functions	 * * *

(DEFUN UPDATE-STATE (LST1
    LST2)
  (SETQ LST2 (WINDOW-STATE))
  (LOOP
    (POP LST2)
    ((NULL LST2))
    (RPLACA LST2 (EVAL (POP LST1))) ) )

(DEFUN WINDOW-PANE LST
  (WINDOW-BOX 0) )

(DEFUN WINDOW-STATES LST
  (WINDOW-BOX 1) )

(DEFUN WINDOW-STATE LST
  ((NULL LST)
    (NTH (WINDOW-PANE) (WINDOW-STATES)) )
  ((CDR LST)
    (REPLACE-NTH (CADR LST) (WINDOW-STATES (CAR LST)) (WINDOW-PANE (CAR LST)))
    (CADR LST) )
  (NTH (WINDOW-PANE (CAR LST)) (WINDOW-STATES (CAR LST))) )

(DEFUN WINDOW-ROW LST
  (WINDOW-BOX 2) )

(DEFUN WINDOW-COL LST
  (WINDOW-BOX 3) )

(DEFUN WINDOW-ROWS LST
  (WINDOW-BOX 4) )

(DEFUN WINDOW-COLS LST
  (WINDOW-BOX 5) )

(DEFUN WINDOW-BOX (NUM)
  ((NULL LST)
    (NTH NUM (NTH *CURRENT-WINDOW* *WINDOWS*)) )
  ((CDR LST)
    (REPLACE-NTH (CADR LST) (NTH (CAR LST) *WINDOWS*) NUM)
    (CADR LST) )
  (NTH NUM (NTH (CAR LST) *WINDOWS*)) )

;		* * *	Option Submenu Commands   * * *

(DEFUN SET-INSERT ()
; Selects line editor input mode.
  (RPLACA (CAR SET-INSERT) (IF *INSERT-MODE* "Insert" "Overwrite"))
  ((MODE-QUERY SET-INSERT)
    (INSERT-STATUS (EQ (CAAR SET-INSERT) "Insert")) ) )

(SETQ SET-INSERT '(("" "Select edit mode" "Edit" ("Insert" "Overwrite"))))

(DEFUN TOGGLE-INSERT ()
  (INSERT-STATUS (NOT *INSERT-MODE*)) )


(SETQ *MUTE* "No")

(DEFUN SET-MUTE ()
; Selects error beep muting.
  (RPLACA (CAR SET-MUTE) *MUTE*)
  ((MODE-QUERY SET-MUTE)
    (SETQ *MUTE* (CAAR SET-MUTE)) ) )

(SETQ SET-MUTE '(("" "Mute warning messages" "Active" ("Yes" "No"))))


(DEFUN GO-DOS (
; Suspends muLISP and executes DOS command.
    COMMAND )
  (SETQ COMMAND (PROMPT-INPUT "Enter DOS command"
		    (PACK* (DEFAULT-DRIVE) ":\\" (DEFAULT-PATH) "> ")))
  ((EQ *LINE-TERMINATOR* 27)  NIL)
  ((PROBE-FILE (GETSET 'COMSPEC))
    (SHOW-PROMPT "")
    ( ((RESTORE-STATE)) 			; Restore external video state
      (MAKE-WINDOW (- *SCREEN-ROWS* 3) 0 3 *SCREEN-COLS*)
      (CLEAR-SCREEN)
      (MAKE-WINDOW NIL)
      (SET-CURSOR (- *SCREEN-ROWS* 3) 0) )
    ( ((EQ COMMAND "")
	(WRITE-LINE (PACK* "Type  EXIT	to return to " *PRODUCT*))
	(EXECUTE (GETSET 'COMSPEC) "") )
      (EXECUTE (GETSET 'COMSPEC) (PACK* "/C " COMMAND))
      (TERPRI)
      (WRITE-STRING "Press any key to continue")
      (CLEAR-INPUT T)
      (LOOP
	((NEQ (READ-CONSOLE-BYTE) 19)) ) )
    (SAVE-STATE)				; Save external video state
    (SET-VIDEO-MODE *VIDEO-MODE* *BORDER-COLOR* *CHARACTER-SET* T)
    (THROW 'SWITCH-SCREEN) )
  (ERROR-MESSAGE "Cannot find COMMAND.COM") )

;		* * *	Color Selection Commands   * * *

(SETQ *WORK-COLOR* 15)
(SETQ *WORK-BACKGROUND* 0)

(DEFUN SET-WORK-COLOR (
    LST)
  ((SETQ LST (SET-COLOR (LIST (CAR (WORK-COLOR)) (CAR (WORK-BACKGROUND)))
			'("Foreground" "Background")))
    (RPLACA (WORK-COLOR) (FIRST LST))
    (RPLACA (WORK-BACKGROUND) (SECOND LST))
    (THROW 'SWITCH-PANE (WINDOW-PANE)) ) )

(DEFUN WORK-COLOR ()
  (NTHCDR (WINDOW-PANE) (NTH 6 (NTH *CURRENT-WINDOW* *WINDOWS*))) )

(DEFUN WORK-BACKGROUND ()
  (NTHCDR (WINDOW-PANE) (NTH 7 (NTH *CURRENT-WINDOW* *WINDOWS*))) )


(SETQ *FRAME-COLOR* 3)
(SETQ *OPTION-COLOR* 7)
(SETQ *PROMPT-COLOR* 13)
(SETQ *STATUS-COLOR* 11)
(SETQ *MENU-BACKGROUND* 0)
(SETQ *BORDER-COLOR* NIL)

(DEFUN SET-MENU-COLOR (
    LST)
  ((SETQ LST (SET-COLOR (LIST *FRAME-COLOR* *OPTION-COLOR*
			    *PROMPT-COLOR* *STATUS-COLOR* *MENU-BACKGROUND*
			    (OR *BORDER-COLOR* (BORDER-COLOR) 0))
			'("Frame" "Option" "Prompt" "Status" "Background"
			    "Border")))
    (SETQ *FRAME-COLOR* (FIRST LST)
	  *OPTION-COLOR* (SECOND LST)
	  *PROMPT-COLOR* (THIRD LST)
	  *STATUS-COLOR* (FOURTH LST)
	  *MENU-BACKGROUND* (FIFTH LST))
    (SET-VIDEO-MODE *VIDEO-MODE* (SIXTH LST) *CHARACTER-SET*)
    (THROW 'SWITCH-SCREEN) ) )


(DEFUN SET-COLOR (LST1 LST2
; Query user for colors and returns a list of color numbers, else NIL.
; LST1 is the current colors and LST2 is the field names.
    NUM)
  (PROMPT-WINDOW)
  (IF (>= *SCREEN-COLS* 60)
      (WRITE-STRING "Enter color number:") )
  (SETQ NUM 0)
  (LOOP 				; Display 16 numbers in color
    ((= NUM 16))
    (CHANGE-COLOR *PROMPT-COLOR* *MENU-BACKGROUND*)
    (SPACES 1)
    (CHANGE-COLOR NUM *MENU-BACKGROUND*)
    (PRIN1 NUM)
    (INCQ NUM) )
  (SETQ LST1 (MAPCAR '(LAMBDA (NUM STRING) (LIST NUM "" STRING 3)) LST1 LST2)
	*PROMPT* ""
	LST2)
  (LOOP 				; Query for new color numbers
    ((NOT (MODE-QUERY LST1 (POSITION-IF 'NOT-COLORP LST2)))  NIL)
    (SETQ LST2 (MAPCAR 'PARSE-INTEGER-CAR LST1))
    ((EVERY 'COLORP LST2)  LST2)
    (ERROR-BEEP) ) )

(DEFUN NOT-COLORP (NUM)
  (NOT (COLORP NUM)) )

(DEFUN COLORP (NUM)
  (AND (INTEGERP NUM) (>= NUM 0)) )

;	    * * *   Display Mode Selection Commands  * * *

(SETQ *VIDEO-MODE* NIL)
(SETQ *CHARACTER-SET* "Extended")
(SETQ *PREVIOUS-MODE* NIL)
(SETQ *PREVIOUS-SET* "Extended")

(DEFUN SET-DISPLAY (
    MODE)
  ((SETQ MODE (VIDEO-MODE))
    ((= MODE 255) NIL)
    (RPLACA (FIRST SET-DISPLAY)
	    (IF (GRAPHICS-MODE-P) "Graphics" "Text") )
    (RPLACA (SECOND SET-DISPLAY)
	    (IF (SMALL-SCREENP) "Medium" "High") )
    (RPLACA (THIRD SET-DISPLAY) *CHARACTER-SET*)
    (RPLACA (FOURTH SET-DISPLAY)
	    (PROGN ((<= MODE 3)
		     ((EQ (CAR (FOURTH SET-DISPLAY)) "") "CGA")
		     (CAR (FOURTH SET-DISPLAY)) )
		   ((<= MODE 6) 	"CGA")
		   ((= MODE 7)
		     ((EQ (CAR (FOURTH SET-DISPLAY)) "") "MDA")
		     (CAR (FOURTH SET-DISPLAY)) )
		   ((<= MODE 10)	"PCjr")
;		   ((= MODE 32) 	"Jaguar")
		   ((<= 64 MODE 66)	"AT&T")
		   ((= MODE 116)	"T3100")
		   ((<= 126 MODE 127)	"Hercules")
		   ((<= 13 MODE 16)	"EGA")
		   ((= MODE 17) 	"MCGA")
		   "VGA" ))
    ((MODE-QUERY SET-DISPLAY)
      (SETQ MODE (PROGN
	((EQ (FIRST (FOURTH SET-DISPLAY)) "MDA")  7)
	((EQ (FIRST (FIRST SET-DISPLAY)) "Text")
	  ((EQ (FIRST (FOURTH SET-DISPLAY)) "Hercules")  7)
;	  ((EQ (FIRST (FOURTH SET-DISPLAY)) "Jaguar")  7)
	  ((EQ (FIRST (SECOND SET-DISPLAY)) "Medium")  1)
	  3 )
;	((EQ (FIRST (FOURTH SET-DISPLAY)) "Jaguar")  32)
	((EQ (FIRST (FOURTH SET-DISPLAY)) "EGA")
	  (RPLACA (CAR EGA-DISPLAY)
		  (PROGN ((<= MODE 3) (CAAR EGA-DISPLAY))
			 ((OR (= MODE 7) (= MODE 15))  "Monochrome")
			 ((<= 16 MODE 18)	       "Enhanced")
			 "Color"))
	  ((MODE-QUERY EGA-DISPLAY)
	    ((EQ (CAAR EGA-DISPLAY) "Monochrome")  15)
	    ((EQ (FIRST (SECOND SET-DISPLAY)) "Medium")  13)
	    ((EQ (CAAR EGA-DISPLAY) "Enhanced")  16)
	    14 )
	  (RETURN) )
	((EQ (FIRST (SECOND SET-DISPLAY)) "Medium")
	  ((EQ (FIRST (FOURTH SET-DISPLAY)) "PCjr")  9)
	  4 )
	(CDR (ASSOC (FIRST (FOURTH SET-DISPLAY))
		    '(("CGA" . 6)  ("PCjr" . 10) ("MCGA" . 17)
		      ("VGA" . 18) ("AT&T" . 64) ("T3100" . 116)
		      ("Hercules" . 126)))) ))
      (IF (NEQL MODE (VIDEO-MODE))
	  (SETQ *PREVIOUS-MODE* (VIDEO-MODE)
		*PREVIOUS-SET* *CHARACTER-SET*) )
      (SET-VIDEO-MODE MODE *BORDER-COLOR* (FIRST (THIRD SET-DISPLAY)))
      (THROW 'SWITCH-SCREEN) ) ) )

(SETQ SET-DISPLAY '(
  ("" "Select display mode" "Mode" ("Text" "Graphics"))
  ("" "Select resolution" "Reso" ("Medium" "High"))
  ("" "Select character set" "Set" ("Standard" "Extended"))
  ("" "Select display adapter" "Adapter"
    ("MDA" "CGA" "EGA" "MCGA" "VGA" "Hercules" "AT&T" "T3100" "PCjr")) ))

(SETQ EGA-DISPLAY '(
  ("Color" "Select monitor type" "Monitor" ("Color" "Enhanced" "Monochrome")) ))


(DEFUN SET-VIDEO-MODE (MODE COLOR CHAR FLAG)
; Sets video mode to MODE, sets border color to COLOR, and updates
; *VIDEO-MODE* and *BORDER-COLOR*.  If FLAG is nonNIL and already in desired
; video mode, the screen is not cleared and SET-VIDEO-MODE returns NIL.
  (MAKE-WINDOW NIL)					; Full screen
  (CURSOR-LINES NIL)					; Normal cursor lines
  (BORDER-COLOR 0)
  ( ((AND FLAG (EQL MODE (VIDEO-MODE))))
    (VIDEO-MODE MODE)
    (SETQ FLAG) )
  ( ((GRAPHICS-MODE-P))
    (BORDER-COLOR COLOR) )
  (SETQ *VIDEO-MODE* (VIDEO-MODE)
	*BORDER-COLOR* COLOR
	*CHARACTER-SET* CHAR)
  (NOT FLAG) )

(DEFUN GRAPHICS-MODE-P (
    MODE)
  (AND (SETQ MODE (VIDEO-MODE)) (>= MODE 4) (/= MODE 7)) )

(DEFUN SMALL-SCREENP ()
  (< *SCREEN-COLS* 75) )

;		* * *	Status Window Functions   * * *

(DEFUN CLEAR-STATUS (PROMPT)
  (STATUS-WINDOW)
  (CLEAR-SCREEN)
  (INSERT-STATUS *INSERT-MODE*)
  (SET-CURSOR 0 (- *SCREEN-COLS* (LENGTH PROMPT)))
  (WRITE-STRING PROMPT T)
  (SET-CURSOR 0 0)
  ((SMALL-SCREENP))
  (SET-CURSOR 0 (- (- *SCREEN-COLS* (LENGTH PROMPT)) (ADD1 (LENGTH *PRODUCT*))))
  (WRITE-STRING *PRODUCT* T)
  (SET-CURSOR 0 0) )

(SETQ *SHOW-INSERT* T)		; Insert status is displayed iff nonNIL.

(DEFUN INSERT-STATUS (MODE)
  (SETQ *INSERT-MODE* MODE)
  ((NOT *SHOW-INSERT*))
  (STATUS-WINDOW)
  (SET-CURSOR 0 (TRUNCATE (* 2 *SCREEN-COLS*) 3))
  ((NOT *INSERT-MODE*)
    (SPACES 6) )
  (WRITE-STRING "Insert") )

;	    * * *   Execute Menu Commands Functions  * * *

(SETQ *OPTION-TREE* NIL)		; Currently displayed option tree
(SETQ *INVERSE-OPTION* NIL)		; Currently highlighted option
(SETQ *EDIT-TERMINATORS* '(27 13 10))	; Edit and menu terminator chars

(DEFUN EXECUTE-OPTION (*OPTION-PROMPT* OPTION-TREE
; Displays prompt and options, and executes option based on user's selection.
    OPTIONS ROWS PROMPT INDENT NUM CHAR POSITION)
  (SETQ OPTIONS OPTION-TREE)
  (LOOP
    (SETQ NUM 0)
    (LOOP
      (LOOP
	( ((LISTEN T))
	  (SHOW-OPTIONS OPTIONS)
	  (SETQ OPTIONS *OPTION-TREE*)
	  ((EQ NUM *INVERSE-OPTION*))
	  (OPTION-WINDOW)
	  (SHOW-OPTION *INVERSE-OPTION* OPTIONS)
	  (SETQ *INVERSE-OPTION* NUM
		*OPTION-TREE* OPTIONS)
	  (CHANGE-COLOR *MENU-BACKGROUND* *OPTION-COLOR* 0)
	  (SHOW-OPTION *INVERSE-OPTION* OPTIONS)
	  (CHANGE-COLOR *OPTION-COLOR* *MENU-BACKGROUND*) )
	((SETQ CHAR (READ-CONSOLE-STATUS)))
	(SHOW-PROMPT "Enter option")
	(PROMPT-WINDOW) )
      ((MEMBER CHAR *EDIT-TERMINATORS*))
      ((OR (SETQ POSITION (POSITION (CHAR-UPCASE (ASCII CHAR)) OPTION-TREE
		    '(LAMBDA (CHAR OPTION) (CHAR= CHAR (CAR OPTION)))))
	   (AND (ALPHA-CHAR-P (ASCII CHAR))
		(SETQ POSITION (POSITION (CHAR-UPCASE (ASCII CHAR)) OPTION-TREE
		    '(LAMBDA (CHAR OPTION) (FINDSTRING CHAR (CAR OPTION)))))))
	(SETQ NUM POSITION) )
      ( ((OR (= CHAR 32) (= CHAR 9))
	  (SETQ NUM (MOD (ADD1 NUM) (LENGTH OPTION-TREE))) )
	((OR (= CHAR 8) (= CHAR 2) (= CHAR -15))
	  (SETQ NUM (MOD (SUB1 NUM) (LENGTH OPTION-TREE))) )
	(ERROR-BEEP) ) )
    ((= CHAR 27)  NIL)
    ( ((EQ OPTIONS *OPTION-TREE*)
	(OPTION-WINDOW)
	(SHOW-OPTION *INVERSE-OPTION* OPTIONS)
	(SETQ *OPTION-TREE* OPTIONS) ) )
    (SETQ *INVERSE-OPTION* NIL
	  CHAR (NTH NUM OPTION-TREE))
    (((LAMBDA (*OPTION-PROMPT*) (IF (ATOM (CDR CHAR))
				    (FUNCALL (CDR CHAR) (CAR CHAR))
				    (EXECUTE-OPTION *OPTION-PROMPT* (CDR CHAR)) ))
	      (IF (EQ *OPTION-PROMPT* 'COMMAND)
		  (STRING-UPCASE (CAR CHAR))
		  (PACK* *OPTION-PROMPT* " " (STRING-UPCASE (CAR CHAR))) ))) ) )

(DEFUN SHOW-OPTIONS (OPTIONS
; Clears option window and displays *OPTION-PROMPT* and OPTIONS, if not already.
; Updates fluids *OPTION-TREE*, *INVERSE-OPTION*, ROWS, PROMPT, and INDENT.
    LST TMP)
  ( ((IDENTITY ROWS))
    (SETQ ROWS (IF (SMALL-SCREENP) 3 2)
	  PROMPT *OPTION-PROMPT*
	  INDENT (+ 2 (LENGTH PROMPT)))
    ((OPTIONS-FIT OPTIONS ROWS))
    (SETQ INDENT 2)
    ((OPTIONS-FIT OPTIONS ROWS))
    (SETQ INDENT 0)
    ((OPTIONS-FIT OPTIONS ROWS))
    (LOOP
      (SETQ PROMPT (SUBSTRING PROMPT (ADD1 (OR (FINDSTRING " " PROMPT)
					       (LENGTH PROMPT)))))
      ((OPTIONS-FIT OPTIONS ROWS))
      ((EQ PROMPT "")
	(SETQ OPTIONS (COPY-ALIST OPTIONS))
	(LOOP
	  (SETQ LST OPTIONS
		TMP "")
	  (LOOP 				; Find longest option name
	    ((NULL LST))
	    ( ((< (LENGTH (CAAR LST)) (LENGTH TMP)))
	      ((UPPER-CASE-P (CHAR (CAAR LST) (SUB1 (LENGTH (CAAR LST))))))
	      (SETQ TMP (CAAR LST)) )
	    (POP LST) )
	  (RPLACA (ASSOC TMP OPTIONS)	 ; Trim off rightmost character
		  (SUBSTRING TMP 0 (- (LENGTH TMP) 2)))
	  ((OPTIONS-FIT OPTIONS ROWS)) ) ) ) )

  ((EQUAL OPTIONS *OPTION-TREE*))
  (OPTION-WINDOW 0)
  (IF (NEQ (WRITE-STRING PROMPT) "") (WRITE-STRING ": "))
  (SETQ *OPTION-TREE* OPTIONS
	*INVERSE-OPTION*)
  (LOOP
    ( ((<= (+ (COLUMN) (LENGTH (CAAR OPTIONS))) *SCREEN-COLS*))
      (TERPRI)
      (SPACES INDENT) )
    (WRITE-STRING (CAAR OPTIONS))
    (POP OPTIONS)
    ((NULL OPTIONS))
    ( ((>= (ADD1 (COLUMN)) *SCREEN-COLS*))
      (SPACES 1) ) ) )

(DEFUN SHOW-OPTION (NUM OPTIONS
; If NUM is nonNIL, displays the NUMth option in OPTIONS.
; Uses fluids: PROMPT, INDENT.
    ROW COL)
  ((NOT NUM))
  (SETQ ROW 0
	COL (IF (EQ PROMPT "") 0 (+ 2 (LENGTH PROMPT))))
  (LOOP
    ( ((<= (+ COL (LENGTH (CAAR OPTIONS))) *SCREEN-COLS*))
      (INCQ ROW)
      (SETQ COL INDENT) )
    ((ZEROP NUM))
    (SETQ COL (+ COL (LENGTH (CAAR OPTIONS))))
    (DECQ NUM)
    (POP OPTIONS)
    (INCQ COL) )
  (SET-CURSOR ROW COL)
  (WRITE-STRING (CAAR OPTIONS)) )

(DEFUN OPTIONS-FIT (OPTIONS ROWS
; Returns T if	PROMPT: OPTIONS  will fit on ROWS option lines with
; subsequent lines indented INDENT spaces, else NIL.
; Fluids: PROMPT, INDENT
    COL)
  (SETQ COL (IF (EQ PROMPT "") 0 (+ 2 (LENGTH PROMPT))))
  (LOOP
    ((ZEROP ROWS)  NIL)
    (LOOP
      ((NULL OPTIONS))
      (INCQ COL (LENGTH (CAAR OPTIONS)))
      ((> COL *SCREEN-COLS*))
      (POP OPTIONS)
      (INCQ COL)
      ((>= COL *SCREEN-COLS*)) )
    ((NULL OPTIONS))
    (DECQ ROWS)
    (SETQ COL INDENT) ) )

;	    * * *   Select Field Options Functions  * * *

(DEFUN MODE-QUERY (OPTIONS NUM1
    NUM COLUMN QUERY ROWS COLS)
  (OPTION-WINDOW 0)
  (WRITE-STRING *OPTION-PROMPT*)
  (WRITE-STRING ": ")
  (SETQ COLUMN (IF (SMALL-SCREENP) 1 (COLUMN))
	NUM 0)
  (LOOP
    ((= NUM (LENGTH OPTIONS)))
    (SETQ QUERY (NTH NUM OPTIONS))
    (IF (> (+ (COLUMN) (LENGTH (THIRD QUERY)) 2 (QUERY-LENGTH (FOURTH QUERY)))
	   *SCREEN-COLS*)
	(SET-CURSOR (ADD1 (ROW)) COLUMN) )
    (IF (ZEROP (COLUMN))
	(SET-CURSOR (ROW) COLUMN) )
    (WRITE-STRING (THIRD QUERY))
    (IF (AND (NEQ (THIRD QUERY) "")
	     (EQ (THIRD QUERY) (STRING-RIGHT-TRIM " " (THIRD QUERY))))
	(WRITE-STRING ": "))
    (PUSH (ROW) ROWS)
    (PUSH (COLUMN) COLS)
    (IF (INTEGERP (FOURTH QUERY))
	(WRITE-STRING (SUBSTRING (MAKE-STRING (CAR QUERY)) 0
				 (SUB1 (MIN (FOURTH QUERY)
					    (- *SCREEN-COLS* (COLUMN))))))
	(SHOW-MODES (CAR QUERY) (FOURTH QUERY)) )
    (SET-CURSOR (ROW) (MIN (SUB1 *SCREEN-COLS*)
			   (+ (CAR COLS) (QUERY-LENGTH (FOURTH QUERY)) 1)))
    (INCQ NUM) )
  (SETQ ROWS (NREVERSE ROWS)
	COLS (NREVERSE COLS)
	NUM (IF (INTEGERP NUM1) (MOD NUM1 (LENGTH OPTIONS)) 0))
  (LOOP
    (SETQ QUERY (NTH NUM OPTIONS))
    (RPLACA QUERY (APPLY 'MAKE-QUERY (NTH NUM ROWS) (NTH NUM COLS) QUERY))
    ((MEMBER *LINE-TERMINATOR* *EDIT-TERMINATORS*)
      (NEQ *LINE-TERMINATOR* 27) )
    ((AND (ZEROP *LINE-TERMINATOR*) (EQ (LENGTH OPTIONS) 1)))
    ( ((OR (EQ *LINE-TERMINATOR* 9) (ZEROP *LINE-TERMINATOR*))
	(SETQ NUM (MOD (ADD1 NUM) (LENGTH OPTIONS))) )
      ((OR (EQ *LINE-TERMINATOR* 2) (EQ *LINE-TERMINATOR* -15))
	(SETQ NUM (MOD (SUB1 NUM) (LENGTH OPTIONS))) ) ) ) )

(DEFUN MAKE-QUERY (ROW COLUMN DEFAULT PROMPT CHAR OPTIONS
    POSITION NUM )
  (SHOW-PROMPT PROMPT)
  ((INTEGERP OPTIONS)
    (OPTION-WINDOW)
    (SET-CURSOR ROW COLUMN)
    (SETQ NUM (CSMEMORY 914 0 T))			; Disable tabbing
    (PROG1 (LINE-EDITOR DEFAULT '(27 13 10 9 2 -15) 0 0 OPTIONS)
	   (CSMEMORY 914 NUM T) ) )			; Enable tabbing
  (SETQ NUM (OR (POSITION DEFAULT OPTIONS) 0))
  (LOOP
    (OPTION-WINDOW)
    (SET-CURSOR ROW (SUB1 COLUMN))
    (SPACES 1)
    (SETQ *LINE-TERMINATOR* (SELECT-OPTION NUM OPTIONS))
    ((MEMBER *LINE-TERMINATOR* '(27 13 10 9 2 -15)))
    ((OR (SETQ POSITION (POSITION (CHAR-UPCASE (ASCII *LINE-TERMINATOR*))
				OPTIONS 'CHAR=))
	 (AND (ALPHA-CHAR-P (ASCII *LINE-TERMINATOR*))
	      (SETQ POSITION (POSITION (CHAR-UPCASE (ASCII *LINE-TERMINATOR*))
				     OPTIONS 'FINDSTRING))))
      (SETQ NUM POSITION
	    *LINE-TERMINATOR* 0) )
    ( ((= *LINE-TERMINATOR* 32)
	(SETQ NUM (MOD (ADD1 NUM) (LENGTH OPTIONS))) )
      ((= *LINE-TERMINATOR* 8)
	(SETQ NUM (MOD (SUB1 NUM) (LENGTH OPTIONS))) )
      (ERROR-BEEP) ) )
  (SETQ DEFAULT (NTH NUM OPTIONS))
  (OPTION-WINDOW)
  (SET-CURSOR ROW COLUMN)
  (SHOW-MODES DEFAULT OPTIONS)
  DEFAULT )

(DEFUN SHOW-MODES (DEFAULT OPTIONS
    MODE NUM)
  (SETQ OPTIONS (TRIM-OPTIONS OPTIONS)
	NUM 0)
  (LOOP
    ((NULL OPTIONS))
    (SETQ MODE (POP OPTIONS))
    ( ((EQ MODE DEFAULT)
	(WRITE-BYTE 8)
	(WRITE-STRING "(")
	(WRITE-STRING MODE)
	(WRITE-STRING ")") )
      (WRITE-STRING MODE)
      (SPACES 1) )
    (INCQ NUM) ) )

(DEFUN SELECT-OPTION (DEFAULT OPTIONS
    MODE NUM)
  (SETQ OPTIONS (TRIM-OPTIONS OPTIONS)
	NUM 0)
  (LOOP
    ((NULL OPTIONS))
    (SETQ MODE (POP OPTIONS))
    ( ((EQ NUM DEFAULT)
	(CHANGE-COLOR *MENU-BACKGROUND* *OPTION-COLOR* 0)
	(WRITE-STRING MODE)
	(CHANGE-COLOR *OPTION-COLOR* *MENU-BACKGROUND*) )
      (WRITE-STRING MODE) )
    ( ((ZEROP (COLUMN)))
      (SPACES 1) )
    (INCQ NUM) )
  (PROMPT-WINDOW)
  (LOOP
    ((READ-CONSOLE-STATUS)) ) )

(DEFUN TRIM-OPTIONS (OPTIONS
    LST TMP)
  ((<= (+ (COLUMN) (QUERY-LENGTH OPTIONS)) *SCREEN-COLS*)  OPTIONS)
  (SETQ OPTIONS (COPY-LIST OPTIONS))
  (LOOP
    ((<= (+ (COLUMN) (QUERY-LENGTH OPTIONS)) *SCREEN-COLS*)  OPTIONS)
    (SETQ LST OPTIONS
	  TMP "")
    (LOOP					; Find longest option name
      ((NULL LST))
      ( ((< (LENGTH (CAR LST)) (LENGTH TMP)))
	((AND (UPPER-CASE-P (CHAR (CAR LST) (SUB1 (LENGTH (CAR LST)))))
	      (> (LENGTH TMP) 1)))
	(SETQ TMP (CAR LST)) )
      (POP LST) )
    ((= (LENGTH TMP) 1)  OPTIONS)
    (SETQ OPTIONS (NSUBSTITUTE (SUBSTRING TMP 0 (- (LENGTH TMP) 2)) TMP OPTIONS)) ) )

(DEFUN QUERY-LENGTH (OPTIONS
    NUM)
  ((INTEGERP OPTIONS)
    (ADD1 OPTIONS) )
  (SETQ NUM (LENGTH OPTIONS))
  (LOOP
    ((NULL OPTIONS) NUM)
    (INCQ NUM (LENGTH (POP OPTIONS))) ) )

;	    * * *   Display Window Border Functions   * * *

(DEFUN BORDER-WINDOWS (
    WINDOW ROW1 COL1 ROW2 COL2)
  (SETQ *CURRENT-AREA*)
  (MAKE-WINDOW NIL)
  (FRAME-COLOR *FRAME-COLOR* *MENU-BACKGROUND*)
  ((ZEROP (WINDOW-ROW 0))
    ((SMALL-SCREENP))
    (HORIZONTAL-BORDER (WINDOW-ROWS 0) 0 *SCREEN-COLS*) )
  (HORIZONTAL-BORDER 0 1 (- *SCREEN-COLS* 2))
  (VERTICAL-BORDER 1 0 (- *SCREEN-ROWS* 6))
  (SETQ WINDOW 0)
  (LOOP
    ((= WINDOW (LENGTH *WINDOWS*)))
    (SETQ ROW1 (SUB1 (WINDOW-ROW WINDOW))
	  COL1 (SUB1 (WINDOW-COL WINDOW))
	  ROW2 (+ (WINDOW-ROW WINDOW) (WINDOW-ROWS WINDOW))
	  COL2 (+ (WINDOW-COL WINDOW) (WINDOW-COLS WINDOW)))
    (SET-CURSOR ROW1 COL1)
    ( ((= WINDOW *CURRENT-WINDOW*)
	(FRAME-COLOR *MENU-BACKGROUND* *FRAME-COLOR* 0)
	(PRIN1 (ADD1 WINDOW))
	(FRAME-COLOR *FRAME-COLOR* *MENU-BACKGROUND*) )
      (PRIN1 (ADD1 WINDOW)) )
    (SET-CURSOR ROW1 COL2)
    ( ((UPPER-LEFT ROW1 COL2))
      ((LOWER-RIGHT ROW1 COL2)
	(WRITE-BORDER 9) )
      (WRITE-BORDER 2) )
    (SET-CURSOR ROW2 COL1)
    ( ((UPPER-LEFT ROW2 COL1))
      ((LOWER-RIGHT ROW2 COL1)
	(WRITE-BORDER 6) )
      (WRITE-BORDER 4) )
    (SETQ ROW1 (ADD1 ROW1)
	  COL1 (ADD1 COL1))
    ( ((AND (= ROW2 (- *SCREEN-ROWS* 5)) (SMALL-SCREENP)))
      (HORIZONTAL-BORDER ROW2 COL1 (- COL2 COL1)) )
    (VERTICAL-BORDER ROW1 COL2 (- ROW2 ROW1))
    (INCQ WINDOW) )
  ((SMALL-SCREENP))
  (SET-CURSOR ROW2 COL2)
  (WRITE-BORDER 5) )

(DEFUN HORIZONTAL-BORDER (ROW COL COLS)
  (SET-CURSOR ROW COL)
  (WRITE-BORDER 0 COLS) )

(DEFUN VERTICAL-BORDER (ROW COL ROWS)
  (SETQ ROWS (+ ROW ROWS))
  (LOOP
    ((>= ROW ROWS))
    (SET-CURSOR ROW COL)
    (WRITE-BORDER 7)
    (INCQ ROW) ) )

(DEFUN WRITE-BORDER (CHAR NUM)
  (WRITE-BYTE (NTH CHAR (IF (EQ *CHARACTER-SET* "Standard")
			    *GENERIC-BORDER*
			    *BORDER-CHARS*))
	      NUM) )

;		* * *	Switch Active Window Functions	 * * *

(SETQ *CURRENT-AREA* NIL)		; Current active window area

(DEFUN CURRENT-WINDOW (FLAG)
  (CHANGE-COLOR (CAR (WORK-COLOR)) (CAR (WORK-BACKGROUND)))
  ( ((EQUAL *CURRENT-AREA*
	    (SETQ *CURRENT-AREA* (CDDR (NTH *CURRENT-WINDOW* *WINDOWS*)))))
    (MAKE-WINDOW (WINDOW-ROW) (WINDOW-COL) (WINDOW-ROWS) (WINDOW-COLS)) )
  ((NOT FLAG))
  (CLEAR-SCREEN) )

(DEFUN OPTION-WINDOW (FLAG
    ROWS)
  (CHANGE-COLOR *OPTION-COLOR* *MENU-BACKGROUND*)
  (SETQ ROWS (IF (SMALL-SCREENP) 3 2)
	*OPTION-TREE*)
  ( ((EQ *CURRENT-AREA* (SETQ *CURRENT-AREA* 'OPTION-WINDOW)))
    (MAKE-WINDOW (- *SCREEN-ROWS* ROWS 2) 0 ROWS *SCREEN-COLS*) )
  ((NOT FLAG))
  (CLEAR-SCREEN) )

(DEFUN PROMPT-WINDOW ()
  ((EQ *CURRENT-AREA* (SETQ *CURRENT-AREA* 'PROMPT-WINDOW)))
  (CHANGE-COLOR *PROMPT-COLOR* *MENU-BACKGROUND*)
  (MAKE-WINDOW (- *SCREEN-ROWS* 2) 0 1 *SCREEN-COLS*) )

(DEFUN STATUS-WINDOW ()
  ((EQ *CURRENT-AREA* (SETQ *CURRENT-AREA* 'STATUS-WINDOW)))
  (CHANGE-COLOR *STATUS-COLOR* *MENU-BACKGROUND*)
  (MAKE-WINDOW (SUB1 *SCREEN-ROWS*) 0 1 *SCREEN-COLS*) )

;	    * * *   Line editor Input Functions   * * *

(DEFUN PROMPT-TEXT-FILE (FILE-NAME FILE-TYPE)
  (SETQ FILE-NAME (STRING-UPCASE
		(PROMPT-INPUT "Enter file name"
			      (PACK* *OPTION-PROMPT* " file: ")
			      FILE-NAME)))
  ((OR (EQ *LINE-TERMINATOR* 27) (EQ FILE-NAME "")) "")
  (NORMALIZE-FILE-NAME FILE-NAME FILE-TYPE) )

(DEFUN NORMALIZE-FILE-NAME (FILE-NAME FILE-TYPE
    NUM)
  (SETQ NUM (IF (EQ (CHAR FILE-NAME 1) '\:) 2 0))
  ( ((EQ (CHAR FILE-NAME NUM) '\.)
      (INCQ NUM)
      ((EQ (CHAR FILE-NAME NUM) '\.)
	(INCQ NUM) ) ) )
  ((SETQ NUM (FINDSTRING '\. FILE-NAME NUM))
    (SUBSTRING FILE-NAME 0 (+ NUM 3)) )
  (PACK* FILE-NAME '\. (OR FILE-TYPE "")) )

(DEFUN PROMPT-INPUT LST
  (SHOW-PROMPT (POP LST))
  (OPTION-WINDOW 0)
  (WRITE-STRING (POP LST) T)
  (LINE-EDITOR (IF LST (CAR LST) "") *EDIT-TERMINATORS*
	       0 0 (- *SCREEN-COLS* (COLUMN) 1)) )

(DEFUN LINE-EDITOR (STRING TERMINATORS *LINE-POINT* *LINE-COLUMN* COLS
    ROW COL )
  (SETQ ROW (ROW)
	COL (COLUMN))
  (LOOP
    (OPTION-WINDOW)
    (SET-CURSOR ROW COL)
    (CURSOR-ON)
    (SETQ STRING (LINE-EDIT STRING *LINE-POINT* *LINE-COLUMN* COLS))
    (CURSOR-OFF)
    ((MEMBER *LINE-TERMINATOR* TERMINATORS)
      (STRING-TRIM " " STRING) )
    ( ((MEMBER *LINE-TERMINATOR* '(11 15)))
      (DEMON-BYTE *LINE-TERMINATOR*) ) ) )

;	    * * *   Single Character Prompt Functions	* * *

(DEFUN CONTINUE-PROMPT (
    BYTE)
  (CLEAR-INPUT T)
  (LOOP
    (SETQ BYTE (PROMPT-READ-BYTE "Press any key to continue"))
    ((NEQ BYTE 19) BYTE) ) )

(DEFUN PROMPT-YN (PROMPT
    BYTE )
  (SETQ PROMPT (PACK* PROMPT " (Y/N)? "))
  (LOOP
    (SETQ BYTE (PROMPT-READ-BYTE PROMPT))
    ((MEMBER BYTE '(89 121 25))
      (WRITE-BYTE 89 NIL T)
      (SETQ *PROMPT*)
      T )
    ((MEMBER BYTE '(78 110 14))
      (WRITE-BYTE 78 NIL T)
      (SETQ *PROMPT*) )
    (ERROR-BEEP) ) )

(DEFUN PROMPT-READ-BYTE (PROMPT)
  (PROMPT-WINDOW)
  (SHOW-PROMPT PROMPT)
  (SET-CURSOR 0 (LENGTH PROMPT))
  (READ-CONSOLE-BYTE) )

(DEFUN ERROR-MESSAGE (PROMPT)
  (SHOW-PROMPT PROMPT)
  (SETQ *PROMPT* "Enter option")
  (ERROR-BEEP)
  (TONE NIL 300) )

(SETQ *PROMPT* "")		; Text currently displayed on prompt line

(DEFUN SHOW-PROMPT (PROMPT)
  ((OR (NULL PROMPT) (EQ PROMPT *PROMPT*)))
  (PROMPT-WINDOW)
  (CLEAR-SCREEN)
  (SETQ *PROMPT* (WRITE-STRING PROMPT T))
  (SET-CURSOR 0 0) )

(DEFUN ERROR-BEEP ()
  ((EQ *MUTE* "Yes"))
  (CLEAR-INPUT)
  ((EQ (CSMEMORY 855) 2)
    (TONE 784 25)
    (TONE 698 50) )
  (WRITE-BYTE 7) )

;	* * *	Garbage Collection Statistics Functions   * * *

(SETQ *FREE-STATUS* NIL)	    ; Name of post-GC statistics display handler
(SETQ *MAX-FREE-SPACE* '(0 0 0))

(DEFUN GCHOOK (
; After GC's, updates free space statistics & funcalls *FREE-STATUS* if nonNIL.
    ROW COL FOREGROUND-COLOR BACKGROUND-COLOR WINDOW
    *CURRENT-AREA* *OUTPUT-FILE*)
  (SETQ *FREE-SPACE* (IF (ZEROP (DSMEMORY 8 NIL T))
			 65536
			 (DSMEMORY 8 NIL T))
	*FREE-SPACE* (LIST (PERCENT (+ (- *FREE-SPACE* (DSMEMORY 6 NIL T))
				       (- (DSMEMORY 2 NIL T) (DSMEMORY 0 NIL T)))
				    *FREE-SPACE*)
			   (PERCENT (- (DSMEMORY 42 NIL T) (DSMEMORY 40 NIL T))
				    (DSMEMORY 42 NIL T))
			   (PERCENT (- (DSMEMORY 44 NIL T) (DSMEMORY 46 NIL T))
				    (- 65536 (DSMEMORY 46 NIL T))))
	*MAX-FREE-SPACE* (MAPCAR 'MAX *FREE-SPACE* *MAX-FREE-SPACE*))
  ((NOT *FREE-STATUS*))
  (SETQ ROW (ROW)
	COL (COLUMN)
	FOREGROUND-COLOR (FOREGROUND-COLOR)
	BACKGROUND-COLOR (BACKGROUND-COLOR)
	WINDOW (MAKE-WINDOW))
  (FUNCALL *FREE-STATUS*)
  (APPLY 'MAKE-WINDOW WINDOW)
  (FOREGROUND-COLOR FOREGROUND-COLOR)
  (BACKGROUND-COLOR BACKGROUND-COLOR)
  (SET-CURSOR ROW COL) )

(DEFUN PERCENT (NUM1 NUM2)
; Returns NUM1/NUM2 rounded to the nearest percent.
  (ROUND (* 100 NUM1) NUM2) )



;	    * * *   General-purpose Utility Functions	* * *

(DEFUN MAKE-STRING (EXPN)
  ((SYMBOLP EXPN) EXPN)
  (PACK* EXPN) )

(DEFUN PARSE-INTEGER-CAR (STRING)
  (PARSE-INTEGER (CAR STRING)) )

(DEFUN PARSE-INTEGER (STRING RADIX
    CHAR SIGN N )
  (SETQ *STRING-INDEX* 0)
  (LOOP
    ((NULL (SETQ CHAR (CHAR STRING *STRING-INDEX*))) NIL)
    ((NEQ CHAR '| |)
      (SETQ SIGN 1)
      ( ((EQ CHAR '+)
	  (INCQ *STRING-INDEX*) )
	((EQ CHAR '-)
	  (SETQ SIGN -1)
	  (INCQ *STRING-INDEX*) ) )
      ((SETQ CHAR (CHAR STRING *STRING-INDEX*))
	((SETQ N (DIGIT-CHAR-P CHAR RADIX))
	  (IF (NULL RADIX) (SETQ RADIX 10))
	  (LOOP
	    (INCQ *STRING-INDEX*)
	    ((NULL (SETQ CHAR (CHAR STRING *STRING-INDEX*))))
	    ((NOT (SETQ CHAR (DIGIT-CHAR-P CHAR RADIX))))
	    (SETQ N (+ (* N RADIX) CHAR)) )
	  (* SIGN N) ) ) )
    (INCQ *STRING-INDEX*) ) )

;		* * *	Keyboard Input Functions   * * *

(SETQ *UPDATE-FUNCTION* NIL)		; Name of function to update window

(DEFUN READ-CONSOLE-STATUS (
    *INPUT-FILE*)
  (LOOP
    (IF *UPDATE-FUNCTION* (FUNCALL *UPDATE-FUNCTION*))
    ((NOT (LISTEN)) NIL)
    ((DEMON-BYTE (READ-CONSOLE-BYTE))) ) )

(DEFUN READ-CONSOLE-BYTE (
    *INPUT-FILE*)
  (CURSOR-ON)
  (PROG1 (CONSOLE-BYTE (READ-BYTE))
	 (CURSOR-OFF)) )


(SETQ *LOCAL-DEMONS* NIL)		; Local demon a-list

(DEFUN DEMON-BYTE (BYTE
    DEMON)
  (SETQ BYTE (NORMALIZE-BYTE BYTE))
  ((SETQ DEMON (OR (ASSOC BYTE *LOCAL-DEMONS*) (ASSOC BYTE *GLOBAL-DEMONS*)))
    (FUNCALL (CDR DEMON) BYTE)
    (IF *UPDATE-FUNCTION* (FUNCALL *UPDATE-FUNCTION*))
    NIL )
  BYTE )

(DEFUN NORMALIZE-BYTE (BYTE)
  ( ((<= -103 BYTE -94) 		;Ctrl Fx --> Shift Fx
      (SETQ BYTE (+ BYTE 10)) )
    ((<= -113 BYTE -104)		;Alt Fx --> Shift Fx
      (SETQ BYTE (+ BYTE 20)) ) )
  ((CDR (ASSOC BYTE *CURSOR-KEYS*)))
  BYTE )

(SETQ *CURSOR-KEYS* '(
	(-72 . 5)			;Up arrow	Ctrl-E
	(-80 . 24)			;Down arrow	Ctrl-X
	(-75 . 19)			;<--		Ctrl-S
	(-77 . 4)			;-->		Ctrl-D
	(-73 . 18)			;PgUp		Ctrl-R
	(-81 . 3)			;PgDn		Ctrl-C
	(-115 . 1)			;Ctrl <--	Ctrl-A
	(-116 . 6)			;Ctrl -->	Ctrl-F
	(-82 . 22)			;Ins		Ctrl-V
	(-83 . 7) ))			;Del		Ctrl-G

(SETQ *GLOBAL-DEMONS* '(
	(22 . TOGGLE-INSERT)		;Ctrl-V (Ins)
	(-59 . NEXT-WINDOW)		;F1
	(-84 . LAST-WINDOW)		;Shift F1
	(-60 . NEXT-PANE)		;F2
	(-85 . LAST-PANE) ))		;Shift F2

;	    * * *   Generic Computer Customization Functions   * * *

(SETQ *GENERIC-BORDER* '(45 32 32 45 32 32 45 124 124 124 43))	;Generic
(SETQ *BORDER-CHARS* *GENERIC-BORDER*)

(MOVD 'IDENTITY 'SAVE-STATE)		;Save external state
(MOVD 'IDENTITY 'RESTORE-STATE) 	;Restore external state
(MOVD 'IDENTITY 'INITIAL-ENTRY) 	;Initial entry routine
(MOVD 'IDENTITY 'CHANGE-COLOR)		;Set foreground and background colors
(MOVD 'WRITE-STRING 'BLINK-WRITE-STRING)
(MOVD 'IDENTITY 'CURSOR-ON)
(MOVD 'IDENTITY 'CURSOR-OFF)
(MOVD 'IDENTITY 'CONSOLE-BYTE)

(DEFUN WRITE-CONSOLE (BYTE)
  (REGISTER 0 512)
  (REGISTER 3 BYTE)
  (INTERRUPT 33) )

;	    * * *   IBM PC Customization Functions   * * *

(IF (EQ (CSMEMORY 855) 2)			;IBM PC?
    (PROGN

(SETQ *BORDER-CHARS* '(205 213 184 209 212 190 207 179 198 181 216))

(DEFUN SAVE-STATE ()
; Save external video state as the list *EXTERNAL-STATE*.
  (SETQ *EXTERNAL-STATE*
	(LIST (FOREGROUND-COLOR) (BACKGROUND-COLOR)
	      (VIDEO-MODE) (BORDER-COLOR))) )

(DEFUN RESTORE-STATE (
; Restores external video state and returns NIL if video mode is not changed.
    *VIDEO-MODE* *BORDER-COLOR*)
  (FOREGROUND-COLOR (FIRST *EXTERNAL-STATE*))
  (BACKGROUND-COLOR (SECOND *EXTERNAL-STATE*))
  (SET-VIDEO-MODE (THIRD *EXTERNAL-STATE*) (FOURTH *EXTERNAL-STATE*)
		  *CHARACTER-SET* T) )

(DEFUN CHANGE-COLOR (FOREGROUND-COLOR BACKGROUND-COLOR FLAG
; Sets the foreground and background color based on 16 logical colors.
; FLAG is nonNIL if for inverse video.
    MODE)
  ((SETQ MODE (VIDEO-MODE))
    ( ((OR (= MODE 7) (= MODE 15) (= MODE 17))		; 3 colors?
	((= FOREGROUND-COLOR BACKGROUND-COLOR)
	  (SETQ FOREGROUND-COLOR 0
		BACKGROUND-COLOR 0) )
	((NOT FLAG)
	  ((ZEROP BACKGROUND-COLOR)			; Normal video?
	    (SETQ FOREGROUND-COLOR (IF (<= FOREGROUND-COLOR 7) 7 15)) )
	  (SETQ FOREGROUND-COLOR 0			; Inverse video?
		BACKGROUND-COLOR 7) )
	((ZEROP FOREGROUND-COLOR)			; Inverse video?
	  (SETQ BACKGROUND-COLOR 7) )
	(SETQ FOREGROUND-COLOR (IF (<= BACKGROUND-COLOR 7) 7 15)
	      BACKGROUND-COLOR 0) )
      ((GRAPHICS-MODE-P)				; Graphics mode?
	((= FOREGROUND-COLOR BACKGROUND-COLOR))
	((OR (= MODE 6) (= MODE 32) (= MODE 64) (<= 126 MODE 127))  ; 2 colors?
	  ((= (LOGAND FOREGROUND-COLOR 1) (LOGAND BACKGROUND-COLOR 1))
	    (IF FLAG (INCQ BACKGROUND-COLOR) (INCQ FOREGROUND-COLOR)) ) )
	((OR (<= 4 MODE 5) (= MODE 10)) 		; 4 colors?
	  ((= (LOGAND FOREGROUND-COLOR 3) (LOGAND BACKGROUND-COLOR 3))
	    (IF FLAG (INCQ BACKGROUND-COLOR) (INCQ FOREGROUND-COLOR)) ) ) )
      ((= FOREGROUND-COLOR BACKGROUND-COLOR)
	(SETQ BACKGROUND-COLOR (LOGAND BACKGROUND-COLOR 7)
	      FOREGROUND-COLOR BACKGROUND-COLOR) )
      (SETQ BACKGROUND-COLOR (LOGAND BACKGROUND-COLOR 7)); Prevents blinking
      ((= FOREGROUND-COLOR BACKGROUND-COLOR)
	(IF FLAG (INCQ BACKGROUND-COLOR) (INCQ FOREGROUND-COLOR))
	(SETQ BACKGROUND-COLOR (LOGAND BACKGROUND-COLOR 7)) ) )
    (IF (= MODE 17) (SETQ BACKGROUND-COLOR (LOGAND BACKGROUND-COLOR 1)))
    (FOREGROUND-COLOR FOREGROUND-COLOR)
    (BACKGROUND-COLOR BACKGROUND-COLOR) ) )

(DEFUN BLINK-WRITE-STRING (STRING
    NUM1 NUM2 MODE)
  (SETQ NUM1 (FOREGROUND-COLOR)
	NUM2 (BACKGROUND-COLOR)
	MODE (VIDEO-MODE))
  ( ((EQ MODE 7)
      (BACKGROUND-COLOR 15) )			;Turn on blinking
    ((EQ MODE 15)
      (FOREGROUND-COLOR 4)
      (BACKGROUND-COLOR 0) )			;Turn on blinking
    ((GRAPHICS-MODE-P)
      (FOREGROUND-COLOR NUM2)
      (BACKGROUND-COLOR NUM1) ) 		;Turn on inverse video
    (BACKGROUND-COLOR (LOGIOR 8 NUM2)) )
  (WRITE-STRING STRING) 			;Write string
  (FOREGROUND-COLOR NUM1)
  (BACKGROUND-COLOR NUM2) )

(DEFUN CURSOR-ON (				;Turn cursor ON
    LST)
  (CURSOR-LINES NIL)
  ((NOT *INSERT-MODE*))
  ((SETQ LST (CURSOR-LINES))
    (CURSOR-LINES (- (CAR LST) 2) (CADR LST)) ) )

(DEFUN CURSOR-OFF ()				;Turn cursor OFF
  ((NOT *CURSOR-ON*)
    (CURSOR-LINES 14 0) ) )

(DEFUN CONSOLE-BYTE (BYTE)
  ((AND (= BYTE 255) (LISTEN))			;Extended function key?
    (- (READ-BYTE)) )
  BYTE )
))

;	    * * *   NEC PC-9801 Customization Functions   * * *

(IF (<= 9 (CSMEMORY 855) 10)			;NEC PC-9801 or Fujitsu?
    (PROGN

(SETQ *BORDER-CHARS* '(149 152 153 145 154 155 144 150 147 146 143))

(DEFUN WRITE-BORDER (CHAR NUM)
  (MAPC 'WRITE-CONSOLE '(27 41 51))		;Activate graphics mode
  (WRITE-BYTE (NTH CHAR *BORDER-CHARS*) NUM)
  (MAPC 'WRITE-CONSOLE '(27 41 48)) )		;Activate kanji mode

(DEFUN RESTORE-STATE () 			;Restore external video state
  (CURSOR-ON)
  NIL )

(DEFUN CURSOR-ON ()				;Turn cursor ON
  (MAPC 'WRITE-CONSOLE '(27 91 62 53 108)) )

(DEFUN CURSOR-OFF ()				;Turn cursor OFF
  ((NOT *CURSOR-ON*)
    (MAPC 'WRITE-CONSOLE '(27 91 62 53 104)) ) )

(DEFUN CONSOLE-BYTE (BYTE)
; Use this definition with a function key table modified using INT DCH.
  ((AND (= BYTE 255) (LISTEN))			;Extended function key?
    (SETQ BYTE (READ-BYTE))
    (REGISTER 0 512)				;AH: 02H
    (INTERRUPT 24)				;AL: INT 18H
    ((AND (ODDP (SHIFT (REGISTER 0) -4))	;Ctrl key pressed?
	  (NTH (- BYTE 71) '(-119 -132 -132 NIL -115 NIL -116 NIL -117 -118 -118))))
    (- BYTE) )
; (REGISTER 0 512)				;AH: 02H
; (INTERRUPT 24)				;AL: INT 18H
; ((AND (ODDP (SHIFT (REGISTER 0) -3))		;Grph key pressed?
;	(ALPHA-CHAR-P (ASCII BYTE)))
;   (- (NTH (- BYTE (IF (>= BYTE 97) 97 65))
;	   '(30 48 46 32 ...))) )
  BYTE )

;(DEFUN CONSOLE-BYTE (BYTE)
; Use this definition with the default function key table.
;  ((AND (EQ BYTE 27) (LISTEN)) 		 ;Function key?
;    (SETQ BYTE (READ-BYTE))
;    ((CDR (ASSOC BYTE '(
;	 (83 . -59)				 ;F1
;	 (84 . -60)				 ;F2
;	 (85 . -61)				 ;F3
;	 (86 . -62)				 ;F4
;	 (87 . -63)				 ;F5
;	 (69 . -64)				 ;F6
;	 (74 . -65)				 ;F7
;;	 (80 . -66)				 ;F8
;	 (81 . -67)				 ;F9
;	 (68 . -83)				 ;Del
;	 (80 . -82) ))))			 ;Ins
;    (UNREAD-CHAR)
;    27 )
;  ((EQ BYTE 127) -68)				 ;F10
;  BYTE )
))


(IF (OR (<= 3 (CSMEMORY 855) 4) 		;ANSI or TI-PC?
	(<= 8 (CSMEMORY 855) 10))		;NEC XA, 9801 or Fujitsu?
    (PROGN

(DEFUN CHANGE-COLOR (FOREGROUND-COLOR BACKGROUND-COLOR)
  ((ZEROP (LOGAND BACKGROUND-COLOR 7))
    (MAPC 'WRITE-CONSOLE '(27 91 48 109)) )	;Normal video
  (MAPC 'WRITE-CONSOLE '(27 91 48 59 55 109)) ) ;Inverse video

(DEFUN BLINK-WRITE-STRING (STRING)
  (MAPC 'WRITE-CONSOLE '(27 91 48 59 53 109))	;Turn blink mode ON
  (WRITE-STRING STRING) 			;Write string
  (MAPC 'WRITE-CONSOLE '(27 91 48 109)) )	;Turn blink mode OFF
))

;	    * * *   Zenith Z-100 Customization Functions   * * *

(IF (EQ (CSMEMORY 855) 5) (PROGN		;Z-100?

(SETQ *BORDER-CHARS* '(97 102 99 117 101 100 117 96 118 116 98))

(DEFUN SAVE-STATE ()				;Disable key expansion
  (MAPC 'WRITE-CONSOLE '(27 122 27 121 63)) )

(DEFUN RESTORE-STATE () 			;Enable key expansion
  (CURSOR-ON)
  (MAPC 'WRITE-CONSOLE '(27 122))
  NIL )

(DEFUN WRITE-BORDER (CHAR NUM)
  (MAPC 'WRITE-CONSOLE '(27 70))		;Activate graphics mode
  (WRITE-BYTE (NTH CHAR *BORDER-CHARS*) NUM)
  (MAPC 'WRITE-CONSOLE '(27 71)) )		;Deactivate graphics mode

(DEFUN CHANGE-COLOR (FOREGROUND-COLOR BACKGROUND-COLOR)
  ((ZEROP (LOGAND BACKGROUND-COLOR 7))
    (MAPC 'WRITE-CONSOLE '(27 113)) )		;Normal video
  (MAPC 'WRITE-CONSOLE '(27 112)) )		;Inverse video

(DEFUN BLINK-WRITE-STRING (STRING)
  (MAPC 'WRITE-CONSOLE '(27 112))		;Turn reverse video ON
  (WRITE-STRING STRING) 			;Write string
  (MAPC 'WRITE-CONSOLE '(27 113)) )		;Turn reverse video OFF

(DEFUN CURSOR-ON ()				;Turn cursor ON
  (MAPC 'WRITE-CONSOLE '(27 121 53)) )

(DEFUN CURSOR-OFF ()				;Turn cursor OFF
  ((NOT *CURSOR-ON*)
    (MAPC 'WRITE-CONSOLE '(27 120 53)) ) )

(SETQ *CURSOR-KEYS* '(		;Z-100 Key	      Generic Key
	(165 . 5)		;Up arrow		Ctrl-E
	(184 . 5)		;Keypad 5		Ctrl-E
	(166 . 24)		;Down arrow		Ctrl-X
	(178 . 24)		;Keypad 2		Ctrl-X
	(168 . 19)		;<--			Ctrl-S
	(180 . 19)		;Keypad 4		Ctrl-S
	(167 . 4)		;-->			Ctrl-D
	(182 . 4)		;Keypad 6		Ctrl-D
	(185 . 18)		;Keypad 9		Ctrl-R
	(249 . 18)		;Shift-Keypad 9 	Ctrl-R
	(179 . 3)		;Keypad 3		Ctrl-C
	(243 . 3)		;Shift-Keypad 3 	Ctrl-C
	(244 . 1)		;Shift-Keypad 4 	Ctrl-A
	(246 . 6)		;Shift-Keypad 6 	Ctrl-F
	(176 . 22)		;Keypad 0		Ctrl-V
	(240 . 22)		;Shift-Keypad 0 	Ctrl-V
	(174 . 7)		;Keypad .		Ctrl-G
	(238 . 7)		;Shift-Keypad . 	Ctrl-G
	(227 . 7)		;D CHR			Ctrl-G

	(163 . 22)		;I CHR			Ctrl-V
	(151 . -59)		;F1			F1
	(215 . -84)		;Shift F1		Shift F1
	(152 . -60)		;F2			F2
	(216 . -85)		;Shift F2		Shift F2
	(228 . 25)		;DELLINE		Ctrl-Y
	(164 . 14)		;INSLINE		Ctrl-N
	(232 . -31)		;Shift <--		Alt-S
	(167 . -32)		;Shift -->		Alt-D
	(229 . -19)		;Shift Up arrow 	Alt-R
	(230 . -46)		;Shift Down arrow	Alt-C
	(173 . -20)		;Keypad -		Alt-T
	(237 . -20)		;Shift-Keypad - 	Alt-T
	(169 . -71)		;HOME			Home
	(183 . -71)		;Keypad 7		Home
	(247 . -119)		;Shift-Keypad 7 	Ctrl-Home
	(233 . -79)		;Shift-HOME		End
	(177 . -79)		;Keypad 1		End
	(241 . -117)		;Shift-Keypad 1 	Ctrl-End
	(141 . -120)		;ENTER			Alt-!
	(205 . -120) )) ))	;Shift-ENTER		Alt-!

; A hook so applications can independently control frame background color:
(MOVD 'CHANGE-COLOR 'FRAME-COLOR)
